perm filename ORDNT.F4[P11,LCS] blob
sn#587479 filedate 1981-05-16 generic text, type T, neo UTF8
C**** ORDNT, LDGLN, TAILS, DOTIT, SAVEM, GETEM ****
SUBROUTINE ORDNT
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON/DAT/RACNT(69),RDOT(17),JXAC(7),RNOTE(22)
COMMON /STF/RSTFAC(0/7),RSTJ2 /WIDTH/WID1,WID2,WIDX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON/PLTR/IPLT,RHT,DIS /POSI/STFF(0/7),JJ2,POS
C ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R4,RJQ(2))
1,(R6,RJQ(4)),(J7,JQ(5)),(J6,JQ(4)),(R5,RJQ(3))
1,(R8,RJQ(6)),(R7,RJQ(5)),(R3,RJQ(1)),(RLVL,RJQ(20))
RB=RMINI+RMINI
C RB SETS SOURCE FOR STEM
WIDX=WID1
C GET STANDARD NOTE WIDTH
IF(J6.LT.0)WIDX=WID2
C P6<0 = WHITE NOTE
C GETS WIDTH OF NOTE DISPLACEMENT
RQ=WIDX
IF(JWHOLE.LT.10)GO TO 1
C SHIFT NOTE TO LEFT OR RIGHT OF STEM (R6=20,10)
C P6 FOR HOMING TO RIGHT(10) OR LEFT(20) OF STEM(10=UP, 20=DOWN)
IF(JWHOLE.EQ.20)RQ=-RQ
R3=R3+RQ*RMINI
1 IF(J6.GE.0)GO TO 125
KL=1
RG=7.
C FOR WHITE NOTES ON DPY.
J7=MOD(J7,10)
IF(J7.EQ.0)GO TO 12122
IF(JTAIL.NE.0)JSTEM=-JSTEM
C SAVE NEG. STEM DIRECTION FOR MARKS ROUTINE
JTAIL=0
IF(IPLT.LT.0)GO TO 2121
IF(J7.NE.2)GO TO 1253
C NO DOTTED DOUBLE WHOLE NOTE??
RQ=POS-18.*RSTJ2+RST7*(RLVL-1.)
CC RQ=POS-18.*RSTJ2+RST7*(R4-1.)
CALL LINX(R3,RQ,R3,RQ+RST7+RST7)
C PUT IN LINE TO SHOW DBL WHOLE ON SCREEN (P7=2)
C SET STEM SHIFT FLAG(J6) FOR ORD. WIDTH NOTES.
12122 IF(IPLT.GE.0)GO TO 1253
2121 J5=15+J7
C IF J7=1, THEN WHOLE NOTE SHAPE INSTEAD OF HALF. (J7=2=DBL. WHL.)
12121 RG=RSTJ2
C RG FOR NOW ;FIX THIS SOME DAY↓↓ SEE 1342+1!
JX4=J4
RQ=R7
CALL DRWNT
C SAVE IT FOR DOTS
C DO I NEED TO NOW?
R7=RQ
CC R4=RX4
J4=JX4
C GET 'EM BACK
RSTJ2=RG
C DRAWS GOOD NOTES ON PLOTTER, NOT ON DPY
RETURN
1251 CALL NOIR(RMINI)
C FOR QUARTER NOTES ON PLOTTER.
RETURN
125 IF(IPLT.LT.0)GO TO 1251
RG=22.
KL=17
1253 CALL RDRAW(KL,RG,RNOTE,RMINI,R3,CENTR,RMINI)
END
C********* FOR LEDGER LINES *********
SUBROUTINE LDGLN
COMMON /STF/RSTFAC(0/7),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/POSI/STFF(0/7),JJ2,POS
C ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (J4,JQ(2)),(J9,JQ(7)) ,(R3,RJQ(1)),(J6,JQ(4))
1,(J12,JQ(10)),(RLVL,RJQ(20))
J4=RLVL
IF(J4.LT.2)GO TO 1
J12=(J4+1)/2-6
C J12 FOR LEDGER LINES ABOVE STAFF
GO TO 2
1 J12=-((3-J4)/2)
C BELOW STAFF
2 RJW=R3-7.*RMINI
RZ=R3+20.*RMINI
IF(J12.LT.0)GO TO 71
JX=J12
JRX=13
GO TO 711
71 JRX=J12*2+3
JX=-J12
711 RX=POS-18*RSTJ2+RST7*JRX
IF(J6.LT.0)RZ=RZ+2*RMINI
126 CALL LINX(RJW,RX,RZ,RX)
1126 IF(JX.EQ.1)RETURN
RX=RX+RSTJ2*14.
JX=JX-1
GO TO 126
END
SUBROUTINE TAILS
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /STF/RSTFAC(0/7),RSTJ2
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (R4,RJQ(2)),(R8,RJQ(6)),(J10,JQ(8)),(RLVL,RJQ(20))
R=RMINI/RSTJ2
RJW=2.*R
R4=RLVL
RA=1.
C FOR VERT. SPACING OF MULTIPLE TAILS
IF(JSTEM.NE.2)GO TO 1127
R=-2.7-R8-R
RJW=-RJW
GO TO 2
1127 R=R8-3.+R
C WAS -3.7 OR -2 BECAUSE ORIGINAL DRAWING OF TAIL WAS OFF.
RA=-RA
2 R4=R4+R
C R4 IS USED IN SUBR. TAIL - R8 IS STEM EXTENSION.
R=R8
R8=0
127 CALL TAIL
JTAIL=JTAIL-1
IF(JTAIL.EQ.0)GO TO 1
R=R+RJW
C RR8 SAVES INFO FOR MRK ROUTINE.
R4=R4+RJW
GO TO 127
1 R8=R
CC R4=R4+2.
IF(J10.GE.0)RETURN
C RJX,RZ MUST BE SAVED PROPERLY AFTER USE IN 'STEM'
RJY=-19.
RH=-RSTJ2*4.
IF(JSTEM.EQ.1)GO TO 1327
C IF(RA.LT.0)GO TO 1327
C NEXT IS FOR STEM DOWN SLASH
RJY=23.
RH=RST7
1327 RJX=RJX-RST7
RJY=RZ+RJY*RSTJ2
RZ=RZ+RH
CALL LINX(RJX,RJY,RJX+17.*RSTJ2,RZ)
C FOR SLASH ON GRACE NOTE TAIL
END
SUBROUTINE DOTIT
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
1 /DAT/RAC(69),RDOT(17) /STF/RSF(8),RSTJ2 /WIDTH/WID1,WID2,WIDX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /PLTR/IPLT,RHT,DIS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (J4,JQ(2)),(J7,JQ(5)),(R3,RJQ(1)),(R7,RJQ(5))
C NEXT FOR NOTES DISPLACED TO LEFT OR RIGHT OF STEM
C MOVES DOT TO RIGHT (THIS SHOULD BE WIDX - BUT OLD FILES WOULD BE WRONG.)
C**** USE WIDX IN FRANCE?
IF(JWHOLE.EQ.20)GO TO 2
IF(JWHOLE.EQ.10.OR.J7.GT.100)RJX=RJX+WID1
2 RJY=CENTR+RSTJ2
IF(MOD(J4,2).EQ.0)GO TO 108
C ON A LINE OR A SPACE?
RX=RST7
IF(J7.GT.100)RX=-RX
C ADD 100 TO R7 FOR DOTS BELOW! NOTE
CC IF(JWHOLE.GE.20.OR.J7.GT.100)RX=-RX
C PERHAPS SHOULD ALWAYS PUT DOT DOWN IF NOTE IS TO LEFT OF STEM??
RJY=RJY+RX
108 RG=9.
IF(IPLT.LT.0)RG=17.
C DOESN'T FILL DOT ON DPY
IF(JDOT.GT.10)JDOT=MOD(JDOT,10)
R=10.*RMINI
107 CALL RDRAW(1,RG,RDOT,RMINI,RJX,RJY,RMINI)
JDOT=JDOT-1
IF(JDOT.EQ.0)RETURN
RJX=RJX+R
CC RJX=RJX+RSTJ2*10.
GO TO 107
END
SUBROUTINE SAVEM
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC /SAV/JJ9,RCEN,RR4,RR6,RR7,RR8,RR9
EQUIVALENCE (R3,RJQ(1)),(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
1,(R7,RJQ(5)),(R8,RJQ(6)),(R9,RJQ(7)),(J9,JQ(7))
RCEN=CENTR
RR4=RLVL
RR6=R6
RR7=R7
RR8=R8
RR9=R9
JJ9=J9
END
SUBROUTINE GETEM
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC /SAV/JJ9,RCEN,RR4,RR6,RR7,RR8,RR9
EQUIVALENCE (R3,RJQ(1)),(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
1,(R7,RJQ(5)),(R8,RJQ(6)),(R9,RJQ(7)),(J9,JQ(7))
CENTR=RCEN
R3=RJAC
RLVL=RR4
R6=RR6
R7=RR7
R8=RR8
R9=RR9
J9=JJ9
END